Ce tutoriel pour le projet de tagging des indicateurs de santé est un vrai projet de bout en bout, de la préparation des données à la restitution de résultats.

Vous pouvez librement digresser au cours de l’étude et pour vous y encourager, 3 exercices vous sont proposés :

  • appliquer des méthodes de calcul de distance entre chaînes de caractères pour identifier des indicateurs semblables et appliquer des techniques type k-NN
  • modéliser le nombre de tags par indicateur
  • finaliser une application shiny d’active learning

L’application de restitution est hors programme mais vous pouvez la consulter (ici)[https://drees.shinyapps.io/Cartographie_des_indicateurs/]

library(data.table)
library(stringi)
library(dplyr)
library(stringr)
library(text2vec)
library(readxl)
library(Matrix)
library(text2vec)
library(rdrop2)
library(ggplot2)
library(plotly)
library(magrittr)
library(slam)
library(stringdist)
library(xgboost)
# GESTION DE LA CONVERSION DES NOMBRES EN CHAINE DE CARACTERES SANS UTILISER LA NOTATION SCIENTIFIQUE
# https://stackoverflow.com/questions/5352099/how-to-disable-scientific-notation
options("scipen"=100, "digits"=10) 

Préparation des données

Base des indicateurs

Aperçu

data2 <- fread("data/29032018_Index2.csv",encoding="Latin-1")
nb_indicateurs=nrow(data2)

Le jeu de données contient indicateurs.

Les données sont principalement textuelles, certaines peut-être plus exploitables que d’autres.

names(data2)
##  [1] "index"                                             
##  [2] "Base"                                              
##  [3] "Indicateur"                                        
##  [4] "Famille"                                           
##  [5] "Famille Finale_DREES"                              
##  [6] "Classement producteur Niveau 3 (le plus détaillé)" 
##  [7] "Classement producteur Niveau 2"                    
##  [8] "Classement producteur Niveau 1 (le moins détaillé)"
##  [9] "thème_DREES"                                       
## [10] "Domaine 1_DREES"                                   
## [11] "Domaine 2_DREES"                                   
## [12] "Domaine 3_DREES"                                   
## [13] "Source"                                            
## [14] "Producteur"                                        
## [15] "Echelle géo. nationale"                            
## [16] "Echelle géo. Rég"                                  
## [17] "Echelle géo dep"                                   
## [18] "Autre échelle de restitution"                      
## [19] "Profondeur historique"                             
## [20] "Fréquence d'actualisation"                         
## [21] "Commentaires"                                      
## [22] "Base"                                              
## [23] "Date version base"                                 
## [24] "Type d'accès"                                      
## [25] "Accéder à la base"                                 
## [26] "Producteur de la base"                             
## [27] "index"
head(data2)#Un View(head(data2,100)) sera peut-être plus approprié pour vous.

Variables doublons

La variable index est présente deux fois !

On vérifie que c’est bien les mêmes valeurs les deux fois puis on supprime

data2[c(!data2[,1]==data2[,27]),c(1,27)]
data2[,27] <- NULL

La variable Base est présente deux fois !

Même procédure, on observe des différences mais c’est seulement des problèmes de majuscules.

head(data2[c(!data2[,2]==data2[,22]),c(2,22)])
data2[c(!tolower(data2[,2])==tolower(data2[,22])),c(2,22)]
data2[,22] <- NULL

En particulier certaines méritent peut-être un pré-traitement, par exemple les noms des producteurs INSEE, DREES, CNAMTS écrit en plein texte.

head(sample(data2$Producteur))
## [1] "Direction de la recherche des études de l’évaluation et des statistiques (DREES), Institut national de la statistique et des études économiques (Insee)"
## [2] "Agence technique de l'information sur l'hospitalisation (ATIH), Institut national de la statistique et des études économiques (Insee)"                  
## [3] "Institut national de la statistique et des études économiques (Insee)"                                                                                  
## [4] "Institut national de la santé et de la recherche médicale (Inserm), Institut national de la statistique et des études économiques (Insee)"              
## [5] "Caisse Nationale de l'Assurance Maladie des Travailleurs Salariés (CNAMTS)"                                                                             
## [6] "Direction de la recherche des études de l’évaluation et des statistiques (DREES), Institut national de la statistique et des études économiques (Insee)"

Traitement des acronymes avec des expressions régulières

Commençons par une expression régulière pour récupérer le texte entre parenthèses (acronyme)

data2$producteur_acronyme=data2$Producteur%>%
  stri_extract_all(regex = "(\\()([A-z]+)(\\))")%>%#On récupère LES chaînes de caractères entre parenthèses
  lapply(function(x)paste(x,collapse=" "))%>%# On les colle
  unlist%>%gsub(pattern = '(\\()|(\\))',replacement = '') # On met en vecteur et on supprime les parenthèses
data2[producteur_acronyme=="NA",producteur_acronyme:=Producteur]#On gère les noms sans acronyme
table(data2$producteur_acronyme)%>%head
## 
##                 Agence de l'eau        Air Paca           ANMDA 
##             153               3               8               1 
##            ANSM             ARS 
##               1             254

Même idée pour la source

data2$source_acronyme=data2$Source%>%
  stri_extract_all(regex = "(\\()([A-z]+)(\\))")%>%#On récupère LES chaînes de caractères entre parenthèses
  lapply(function(x)paste(x,collapse=" "))%>%# On les colle
  unlist%>%gsub(pattern = '(\\()|(\\))',replacement = '') # On met en vecteur et on supprime les parenthèses
data2[source_acronyme=="NA",source_acronyme:=Source]#On gère les noms sans acronyme
table(data2$source_acronyme)%>%head
## 
##                             Accidents de la circulation 
##                        2283                           3 
##                       Adeli                  Adeli RPPS 
##                           9                          13 
##                       AGATA                         ALD 
##                           3                          82

Suppression des stop-words

Pour remplacer plusieurs mots d’un coup, stringr propose une fonction polymorphe très pratique str_replace_all. Lorsqu’on fournit un vecteur nommé à la place des paramètres pattern et replacement, la fonction est appliquée au vecteur de sorte que pour chaque entrée du vecteur, le nom joue le rôle de pattern et la valeur joue le rôle de replacement.

On commence par construire notre liste de stopwords.

stop_words = tm::stopwords(kind="fr")
# stop_words=c(stop_words,"actifs part entière APE")
stop_words=paste0(" ",stop_words," ")
stop_words=c(stop_words," c'"," l'"," d'"," j'"," t'"," m'"," s'")
fix_stop=rep(" ",length(stop_words))
names(fix_stop) <- stop_words

Puis on passe en minuscules, on supprime les stopwords puis les espaces en trop.

data2 <- data2%>%
  mutate(Indicateur=as.character(Indicateur))%>%#passage en char
  mutate_if(is.character,tolower)%>%#en minuscules
  mutate_if(is.character,function(x)str_replace_all(x,fix_stop))%>%#suppression de stopwords génériques et spécifiques
  mutate_if(is.character,tm::stripWhitespace)#suppression des doubles espaces

Suppression des colonnes constantes

cardinality=sapply(data2,function(x)length(unique(x)))
head(cardinality)
##                                             index 
##                                             18885 
##                                              Base 
##                                                25 
##                                        Indicateur 
##                                             18360 
##                                           Famille 
##                                              1933 
##                              Famille Finale_DREES 
##                                                 1 
## Classement producteur Niveau 3 (le plus détaillé) 
##                                               410
data2=data2[,cardinality>1]

Construction du bloc de texte

data2$Indicateur_enriched=paste(data2$Indicateur,
                                data2$Famille,
                                data2$`Classement producteur Niveau 1 (le moins détaillé)`,
                                data2$`Classement producteur Niveau 2`,
                                data2$`Classement producteur Niveau 3 (le plus détaillé)`,
                                data2$source_acronyme,data2$producteur_acronyme)

Longueur du texte :

nchar(data2$Indicateur)%>%hist(main="Distribution du nombre de caractères dans le texte")

On va compter les espaces pour se donner une idée du nombre de mots

str_count(data2$Indicateur," ")%>%hist(main="Distribution du nombre de mots dans le texte")

Les tags

Aperçu

Chaque indicateur taggé par machine learning a ensuite été validé par son producteur qui nous a renvoyé un fichier excel, ce qui fait une trentaine de fichiers Excel homogénéisés et empilés. On sautera cette étape et on travaillera directement sur le fichier intermédiaire : tagged_triplet_agreg.RData

load("tagged_triplet_agreg.RData")

La fameuse liste des tags.

names(tagged)
##  [1] "index"                                                       
##  [2] "Population_generale"                                         
##  [3] "Personnes_agees"                                             
##  [4] "Enfants__adolescents__jeunes_adultes"                        
##  [5] "Population_precaire"                                         
##  [6] "Personnes_handicapees"                                       
##  [7] "Sante_des_femmes_perinatalite"                               
##  [8] "Diabete_et_autres_maladies_endocriniennes"                   
##  [9] "Sante_mentale"                                               
## [10] "Cancer"                                                      
## [11] "Maladie_de_l_appareil_genito_urinaire"                       
## [12] "Maladies_cardiovasculaires"                                  
## [13] "Maladies_neurologiques_ou_degeneratives"                     
## [14] "Maladies_respiratoires"                                      
## [15] "Maladies_de_l_appareil_digestif"                             
## [16] "Maladies_infectieuses"                                       
## [17] "Pathologies_du_systeme_osteo_articulaire"                    
## [18] "Traumatismes_et_pathologies_accidentelles"                   
## [19] "Autres_pathologies"                                          
## [20] "Coordination_continuite"                                     
## [21] "Qualite_et_securite_des_soins"                               
## [22] "Prevention_depistage"                                        
## [23] "Accessibilite_geographique_financier_autres"                 
## [24] "Habitudes_de_vie_et_addictions"                              
## [25] "Determinants_environnementaux"                               
## [26] "E_sante_systemes_d_information"                              
## [27] "Droits_d_usagers_democratie_sanitaire"                       
## [28] "Mesures_d_inegalites_et_de_disparites_territoriales_de_sante"
## [29] "Contexte_demographique_et_socio_economique"                  
## [30] "Offre_de_soins"                                              
## [31] "Offre_medico_sociale"                                        
## [32] "Recours_aux_soins"                                           
## [33] "Protection_sociale"                                          
## [34] "Depenses_de_sante"                                           
## [35] "Etat_de_sante"                                               
## [36] "Determinants_professionnels"
names(tagged) <- tolower(names(tagged))

Pour l’instant on dispose d’un tableau avec une ligne par indicateur et pour chaque colonne un ‘top’ tag ie un booléen qui nous indique si le tag est appliqué.

head(tagged[,1:10])

Nombre de tags par indicateur

Si on aime le jargon ADD (ACM) on peut parler de tableau disjonctif de la variable ‘tag’ à ceci près que plusieurs modalités sont possibles en même temps…

Justement, combien de tags par indicateur ?

rowSums(tagged%>%select(-index))%>%hist

Fréquence des tags

On a donc principalement entre 2 et 4 tags par indicateur.

Maintenant quelle est la fréquence de chaque tag ?

sapply(tagged,mean)[-1]%>%
  data.table(name=names(.),freq=.)%>%{
  ggplot(data=.,aes(x=name,y=freq))+
      geom_bar(stat="identity")+ 
      theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())}%>%
  ggplotly

Corrélation des tags

On calcule les corrélations entre les tags et on supprime (met à 0) celle inférieure à 10% et celles à 1 qui vont polluer visuellement le graphe.

cor_mat=cor(tagged%>%select(-index))
cor_mat[abs(cor_mat)<.1] <- 0
cor_mat[cor_mat==1] <- 0

Ce package ne gère par les valeurs négatives donc on prendra les valeurs absolues.

chorddiag::chorddiag(abs(cor_mat),showTicks = F,showGroupnames = F)
## Warning in RColorBrewer::brewer.pal(n, palette): n too large, allowed maximum for palette Dark2 is 8
## Returning the palette you asked for with that many colors

Cette information sur la corrélation entre les tags est importante. Elle devra orienter notre choix méthodologique. En effet on ne peut pas considérer que les tags sont indépendants.

Matrice sparse

La densité de la matrice de tags vaut 8.2 %.

On préfère le format triplet qui nous servira ensuite pour une représentation en matrice creuse (sparse)

tagged_triplet=reshape::melt(tagged,id.vars="index")

head(tagged_triplet)

Base indicateurs x tags

Jointure

tagged_triplet=merge(tagged_triplet,data2%>%select(index,Base,Indicateur),by="index") %>% mutate_if(is.factor,as.character)

tagged_triplet %<>% rename(id=index)
tagged_triplet=data.table(tagged_triplet)

Numérotation des lignes

On récupère la liste des tags pour les numéroter.

tags <- unique(tagged_triplet$variable)
tags_corres=data.frame(tags=tags,tag_id=1:length(tags),stringsAsFactors = F)
tagged_triplet=merge(tagged_triplet,tags_corres,by.x="variable",by.y="tags")

On numérote les lignes issues du croisement indicateur x tag pour pouvoir ensuite définir manuellement une matrice sparse exploitable par XGBOOST.

tagged_triplet <- tagged_triplet%>%mutate(i=(tag_id-1)*nb_indicateurs+id)#%>%select(-tag_id)

On gère les problèmes de doublons et on récupère les numéros des indicateurs qui ont été taggés, c’est uniquement sur ces indicateurs qu’on pourra entraîner/vérifier le modèle.

tagged_triplet=data.table(tagged_triplet)[,.SD[1],by="i"]
tagged_ids = unique(tagged_triplet$id)

Vectorisation du text avec text2vec

Les tags

On remplace les séparateurs _ par des espaces pour que la fonction reconnaisse les tokens.

Pour les tags on va un peu vite parce qu’il n’y a pas beaucoup d’enjeux, on est sur quelques dizaines de mots, chaque est important. On décide de cette approche parce qu’on pense que le mots “soin”, “offre”, “population”, “maladie”, “pathologie”, etc. qui sont présents dans plusieurs tags, devraient être pris en compte par le modèle.

tags_dtm <- tags%>%
  gsub(pattern = "_",replacement = " ")%>%#conversion _ en " "
  str_replace_all(fix_stop)%>%#suppression des stopwords
  itoken(tolower,word_tokenizer)%>% # extraction des tokens
  {create_dtm( # Création d'un dtm...
    vocab_vectorizer( # A partir de la matrice du texte vectorisé ...
      create_vocabulary(.,ngram=c(1L,3L)) # A partir d'un vocabulaire de 1 grams à 3 grams
    ),it=.)
  }
dimnames(tags_dtm)[[1]] <- tags

Le problème c’est qu’on a créé beaucoup d’hapax ie des façons différentes de représenter le même tag ! On veut supprimer ces doublons.

col_to_rm=c()
for (i in 1:(ncol(tags_dtm)-1)){
  for(j in (i+1):ncol(tags_dtm)){
    if(sum(tags_dtm[,i]==tags_dtm[,j])==nrow(tags_dtm)){
    col_to_rm=c(col_to_rm,j)
    }
  }
}
col_to_rm=sort(unique(col_to_rm))

Chaque tag contient :

  • Une représentation si c’est suffisant (aucun mot partagé avec les autres tags)
  • Plusieurs si certains des mots (ou ngram) sont présents dans d’autre tags
tags_dtm=tags_dtm[,-col_to_rm]
rowSums(tags_dtm)
##                                          population_generale 
##                                                            2 
##                                           autres_pathologies 
##                                                            3 
## mesures_d_inegalites_et_de_disparites_territoriales_de_sante 
##                                                            2 
##                    diabete_et_autres_maladies_endocriniennes 
##                                                            3 
##                        maladie_de_l_appareil_genito_urinaire 
##                                                            2 
##                   contexte_demographique_et_socio_economique 
##                                                            1 
##                              maladies_de_l_appareil_digestif 
##                                                            3 
##                                   maladies_cardiovasculaires 
##                                                            2 
##                                              personnes_agees 
##                                                            2 
##                    traumatismes_et_pathologies_accidentelles 
##                                                            2 
##                                                       cancer 
##                                                            1 
##                         enfants__adolescents__jeunes_adultes 
##                                                            1 
##                                qualite_et_securite_des_soins 
##                                                            2 
##                                         prevention_depistage 
##                                                            1 
##                                            recours_aux_soins 
##                                                            2 
##                                         offre_medico_sociale 
##                                                            3 
##                  accessibilite_geographique_financier_autres 
##                                                            2 
##                                          population_precaire 
##                                                            2 
##                                determinants_environnementaux 
##                                                            2 
##                                                sante_mentale 
##                                                            2 
##                               habitudes_de_vie_et_addictions 
##                                                            1 
##                                        personnes_handicapees 
##                                                            2 
##                                            depenses_de_sante 
##                                                            2 
##                      maladies_neurologiques_ou_degeneratives 
##                                                            2 
##                                        maladies_infectieuses 
##                                                            2 
##                                sante_des_femmes_perinatalite 
##                                                            2 
##                               e_sante_systemes_d_information 
##                                                            2 
##                     pathologies_du_systeme_osteo_articulaire 
##                                                            2 
##                        droits_d_usagers_democratie_sanitaire 
##                                                            1 
##                                                etat_de_sante 
##                                                            2 
##                                               offre_de_soins 
##                                                            3 
##                                  determinants_professionnels 
##                                                            2 
##                                      coordination_continuite 
##                                                            1 
##                                       maladies_respiratoires 
##                                                            2 
##                                           protection_sociale 
##                                                            2

La vision complémentaire : les termes présents dans plusieurs tags

colSums(tags_dtm)%>%sort(decreasing = T)%>%head(10)
##     maladies        sante  pathologies       autres        soins 
##            6            6            3            3            3 
##        offre      sociale     appareil determinants   population 
##            2            2            2            2            2

On garde ces informations sur les tags pour plus tard

i_tags=summary(tags_dtm)$i
j_tags=summary(tags_dtm)$j
dimnm_tags=dimnames(tags_dtm)

Les indicateurs

On commence par appliquer des standardisations avancées au texte : suppression des accents, stemming ou lemmatisation.

Stemming

Si vous voulez tester, vous pouvez reprendre le code du TD text-mining avec le package SnowballC. N’oubliez pas de “remplir” le stem avec stemCompletion du package tm afin d’obtenir un résultat un minimum lisible.

Lemmatisation

On commence par placer le texte dans un vecteur et supprimer les accents.

text <- data2$Indicateur_enriched
text=iconv(text,from="UTF-8",to="ASCII//TRANSLIT")

Pour commencer il faut installer treetagger et ajouter les variables d’environnement pour pouvoir l’appeler en ligne de commande.

On ajoute “azerty” pour servir de séparateur d’indicateursles caractères spéciaux même rares comme | sont déjà présents dans le txt

fwrite(x = list(paste(text,"azerty")),"indicateurs.txt")
readLines("indicateurs.txt",3)
## [1] "montants infra-annuels remboursement soins generalistes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"
## [2] "montants infra-annuels remboursement soins specialistes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"
## [3] "montants infra-annuels remboursement soins sages femmes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"

On lance treeTagger : ça prend 12 secondes sur mon X270. C’est vraiment rapide. SINON si on devait gérer un texte plus long on commencerait par extraire le vocabulaire et on appliquerait treeTagger uniquement sur le vocabulaire pour éviter d’appliquer plusieurs fois les mêmes opérations… ** Au cas où vous auriez des difficultés à installer treeTagger, je vous ai fourni le fichier indicateurs_tagtreed2.txt**

system.time(system("tag-french indicateurs.txt > indicateurs_tagtreed2.txt")) 

On regarde ce que ça donne.

tagged_parsed=fread("indicateurs_tagtreed2.txt",fill=T,header=F)
names(tagged_parsed) <- c("mot_original","type_de_mot","mot_lemme")
head(tagged_parsed,10)
tail(tagged_parsed,10)
tagged_parsed=tagged_parsed[-nrow(tagged_parsed),]# on supprime la dernière ligne, pas besoin du dernier séparateur.

On peut regarder comment les mots ont été taggés (on parle de tags là aussi… attention au risque de confusion)

tagged_parsed[grep("cardio",tagged_parsed$mot_original),]

En investiguant les différents tags on identifie deux tags inutiles relatifs à la ponctuation et aux nombres.

tagged_parsed%>%filter(mot_lemme=="@card@")%>%head
tagged_parsed%>%filter(type_de_mot=="SENT")%>%head

On les supprime :

ajustement_text=tagged_parsed%>%
  filter(!type_de_mot%in%c("PUN","SENT"))%>%
  mutate(text_ajuste=ifelse(type_de_mot=="NUM",mot_original,mot_lemme))

Puis on reconstitue notre vecteur d’indicateurs lemmatisés et nettoyés

big_txt=paste(ajustement_text$text_ajuste,collapse=" ")
split_txt=strsplit(big_txt,split = "azerty")
split_txt=iconv(unlist(split_txt),'UTF-8','latin1')
head(sample(split_txt))
## [1] "   tau|taux standardiser mortalite cancer uterus pop ref rp 2006 tau|taux standardiser mortalite tumeur pathologie tumeur cancer uterus base cepidc recensement population inserm insee "                                                                                               
## [2] "   tau|taux salarier rythme travail imposer cadence automatique un machine sexe secteur activite priver intensite marge manouvre risquer professionnel contrainte organisationnel enquete surveillance medicale exposition salarier risque professionnel enquete sumer dares dgt dgafp "
## [3] "  depassements moyen medecins liberaux specialistes total radiologie 72 74 76 06 depassements moyen medecins specialistes liberaux professionnel sante liberaux honoraire honoraire|honoraires total moyen snir cnamts "                                                                
## [4] "   tau|taux comparatif deces symptomes mal definis pop ref rhone-alpes rp 2008 tau|taux comparatif deces etat sante population cause medicales deces symptomes mal definis base cepidc recensement population inserm insee "                                                            
## [5] " nombre commune ensemble petit commune ou financement analyser besoin social ne être financee/portee cias le analyse besoin social aider action social action social commun intercommunalites le organisation le action social territoire communal 2014 asco drees insee "              
## [6] "   psy detail recette daf recette psychiatrie activite restitution medico-economiques psychiatrie donnees agregees base arbust base hapi atih "

Comme précédent on génère le vocabulaire sur les n-grams 1-3 avec les fonctions de text2vec

tokens = word_tokenizer(split_txt)
it = itoken(tokens, progressbar = FALSE)
vocab = create_vocabulary(it, ngram = c(1L, 3L))
vocab_init=nrow(vocab)
vocab = prune_vocabulary(vocab, term_count_min = 3L)
vocab_pruned_freq=nrow(vocab)

On est très léger sur le filtrage du vocabulaire, on a seulement supprimé les termes présents moins de 3 fois… On est parti d’un vocabulaire de taille 68422 pour arriver à un vocabulaire de taille 31114.

On jongle entre les formats de matrices creuses, essayez de comprendre ce qui diffère entre les diverses représentations dgTMatrix, dgCMatrix, ngCMatrix…

vectorizer = vocab_vectorizer(vocab)
dtm=create_dtm(it,vectorizer,type = "dgCMatrix")
dtm=as(dtm, "ngCMatrix")

Finalement on récupère les informations qui nous intéressent pour construire par la suite une matrice sparse dans un autre format, celui ingéré par xgboost.

i=summary(dtm)$i
j=summary(dtm)$j
dimnm=dimnames(dtm)

Les notions

Aperçu

Avec des experts médicaux on a construit une liste de synonymes ou notions clefs qui permettent d’attribuer un tag à un indicateur. On va utiliser cette liste pour gérer le tagging des cas triviaux.

notions <- readxl::read_xlsx("20180426_Dictionnaire des notions edited.xlsx")
names(notions) <- tolower(names(notions))
names(notions)[!names(notions)%in%tags]
## character(0)

On empile les colonnes et on traite le texte (passage en lettres minuscules)

notions <- lapply(1:ncol(notions),function(i){
  data.frame(notion=names(notions)[i],termes=unname(notions[,i]))%>%
    na.omit%>%
    mutate_all(as.character)
}
)%>%
  do.call(what = "rbind")%>%
  mutate(termes=tolower(termes))

head(notions)
nrow(notions)
## [1] 345

On supprime les accents et on lemmatise

notions_txt=notions$termes
notions_txt=iconv(notions_txt,from="UTF-8",to="ASCII//TRANSLIT")
fwrite(x = list(paste(notions_txt,"azerty")),"notions_2B_lem.txt")
readLines("notions_2B_lem.txt",10,encoding = "utf8")
system.time(notions_lemmed <- system("tag-french notions_2B_lem.txt",intern = T))
fwrite(list(notions_lemmed),"notions_lemmatized.txt")

On effectue les mêmes traitements que précédemment : on supprime les ponctuations et nombres… et on reconstruit le vecteur de texte.

Attention, il est nécessaire d’appliquer strictement les mêmes transformations sur le texte des indicateurs et le texte des notions afin de pouvoir apparier (grep) les deux.

Encore une fois, si treeTagger ne fonctionne pas sur votre poste, il vous suffit de récupérer notions_lemmatized.txt.

notions_lemmatized=fread(input = "notions_lemmatized.txt",sep="\t",fill=T,header=F)
names(notions_lemmatized) <- c("mot_original","type_de_mot","mot_lemme")
notions_lemmatized=notions_lemmatized[1:(nrow(notions_lemmatized)-4)]
notions_lemmatized=notions_lemmatized%>%
  filter(!type_de_mot%in%c("PUN","SENT"))%>%
  mutate(text_ajuste=ifelse(type_de_mot=="NUM",mot_original,mot_lemme))
notions_lemmatized=paste(notions_lemmatized$text_ajuste,collapse=" ")
stringr::str_count(notions_lemmatized,"azerty")
## [1] 344
notions_lemmatized=strsplit(notions_lemmatized,split = "azerty")[[1]]
sum(stringr::str_count(notions_lemmatized,"azerty"))
## [1] 0
head(notions_lemmatized)
## [1] "addiction "                                                                            
## [2] " centrer accueil et accompagnement avoir le reduction de risque pour usager de drogue "
## [3] " contraception "                                                                       
## [4] " depistage "                                                                           
## [5] " education "                                                                           
## [6] " mst "
notions_lemmatized=tm::stripWhitespace(notions_lemmatized)
notions_lemmatized=gsub("^ ","",notions_lemmatized)
notions_lemmatized=gsub(" $","",notions_lemmatized)
length(notions_lemmatized)==nrow(notions)
## [1] TRUE
notions$termes=notions_lemmatized
notions=unique(notions)

Matching avec les indicateurs

On va construire une variable (qui sera la dernière variable du tableau, après la vectorisation du texte) à partir des notions qui nous indique si l’un des termes relatifs à un tag est présent pour un indicateur. La fonction centrale est str_which.

notions$tag_id=sapply(notions$notion,function(x)which(tags==x))
nb_ngram_indic=max(j)
nb_features=max(j)+max(j_tags)

system.time(match_notions_indic <- do.call("rbind",pbapply::pbsapply(1:nrow(notions),
         function(index){
           matching=str_which(pattern = paste0("(^|( ))(",notions$termes[index],")(( )|($))"),
                              string = split_txt)#text
           if(length(matching)>0){
             data.frame(i= matching,
                        tag_id=notions$tag_id[index],
                        j=nb_features+1,notion=notions$termes[index], stringsAsFactors = F)
           } else NULL
         }
)))
##    user  system elapsed 
##   30.50    0.96   31.76
head(match_notions_indic)
  • i => ligne = numéro de l’indicateur récup avec split_txt
  • j => colonne = numéro du token dans la sparse matrix
  • tag_id => tag associé
  • N’oubliez pas qu’on fera un modèle binomial ie indicateur x tag = TRUE/FALSE

Pertinence des notions

tags_ok=tagged_triplet
tags_ok=merge(match_notions_indic,tags_ok,by.x=c("i","tag_id"),by.y=c("id","tag_id"),all.y=T)

table(!is.na(tags_ok$j)# On a fait une jointure à droite donc !is.na signifie qu'il y a eu matching notion <-> indicateur
      ,tags_ok$value # 1 = tag ok pour cet indic, 0 = tag ko pour cet indic
      )
##        
##              0      1
##   FALSE 190012  13991
##   TRUE    2085   3618

Plus précisément, investiguons les termes problématiques.

table(tags_ok$notion# les notions qui génèrent le tagging automatique
      ,tags_ok$value # 1 = tag ok pour cet indic, 0 = tag ko pour cet indic
      )
##                               
##                                  0   1
##   accident                      47  74
##   accouchement                   2  50
##   addiction                      3   4
##   adenome                        0   8
##   adolescent                     0  58
##   agees                         13  76
##   amygdalectomie                 0   2
##   appendicectomie                0   3
##   asthme                         2   1
##   biologie medicale              2   7
##   bronchite                      0   2
##   brulure                        0   5
##   cancer                         3 824
##   cancerologie                   0  23
##   cannabis                      86   0
##   cardiaque                      0   9
##   cataracte                      0   2
##   chimiotherapie                 0  33
##   chirurgie generale             3   0
##   chirurgie testiculaire         1   1
##   chirurgie vasculaire           0   2
##   cholecystectomie               0   2
##   clic                           1   0
##   cmu                            5   0
##   cmuc                          12   5
##   cognitif                       5   0
##   coloscopie                     0  34
##   contraception                  1   1
##   coordination                   0   5
##   dent                           1   2
##   dentaire                       1  26
##   dentiste                       2  46
##   depistage                      0 210
##   dialyser                       0  10
##   digestif                      78  86
##   droguer                       10   4
##   ecg                            2   0
##   education                      8   4
##   endoscopie digestif            0   3
##   enfant                        21 114
##   epaule                         0   3
##   epilepsie                      0  13
##   feminin                        0   4
##   feminine                       0   2
##   femme                         11 248
##   fondre aide                    2   0
##   fragilite economique           7   0
##   fragilite socio                0   2
##   genou                          2   8
##   glycemie                       2   0
##   grossesse                      3  29
##   gynecologue                    3   2
##   hancher                        0   5
##   handicap                       3  16
##   handicapees                   10  12
##   handicaper                    19  35
##   hebergement social             2   1
##   hemodialyse                    0  10
##   hepatite                       1   1
##   hepatologie                    0   3
##   hypertension                   0   6
##   incapacite                     5   0
##   infarctus                      0   9
##   insuffisance cardiaque         0   1
##   insuline                       0   8
##   invalide                       0   4
##   invalidite                     6  21
##   ipp                            1   0
##   jeune                          4  20
##   kinesitherapeutes              9   9
##   main                           0   2
##   maladie alzheimer              4   2
##   masseur                        1   1
##   mdph                           3   0
##   medecine genetique             0   2
##   medecine interne               4   0
##   medecine nucleaire             1   1
##   migrainer                      0   3
##   mineur                         0   4
##   nerveux                       47   5
##   neurochirurgie                 0   2
##   non programmer                 1   0
##   obesite                        3   0
##   ophtalmologie                  0   3
##   ophtalmologue                  2  13
##   orientation                    0   2
##   orthophoniste                  1  17
##   parcourir                      1  15
##   perinatale                     4  79
##   pertinence                     0   3
##   pneumologie                    0   3
##   pneumonie                      0   1
##   poignet                        0   2
##   polyarthrite rhumatoide        0   2
##   poumon                         2  43
##   prado                          0  12
##   premature                      3   0
##   prevention                   332  86
##   prostatectomie transuretrale   0   3
##   prothese dentaire              0   4
##   psy                           13 254
##   psychiatrie                   11 315
##   psychiatrique                  8  24
##   psychique                      0   9
##   psychoactives                437  14
##   psychologique                  1   2
##   psychotrope                   91  31
##   radiodiagnostic                0   1
##   radiophysiciens                0   1
##   radiotherapie                125   4
##   reanimation medicale           0   3
##   rectocolite                    0   1
##   rehospitalisation              4   2
##   rhumatologie                   0   3
##   rhumatologue                   0   2
##   rougeole                       0   3
##   rsa                            0   6
##   sante mental                   4  34
##   satisfaction                   0   1
##   securite                       7   8
##   sevrage                        0   4
##   sida                           1  26
##   specialistes                 112  53
##   stomatologie                   0   8
##   substance                    439  14
##   suicider                       2  26
##   test positif                   0   6
##   testiculaire                   1   1
##   thyroide                       7  19
##   trachee                        1   7
##   trouble mental                 7 105
##   tuberculose                    0   3
##   tumeur                         1  75
##   vaccin                         0   2
##   vaccination                    0   7
##   vieillesse                     5   2
##   vih                            0  24

psychoactives, cannabis, radiothérapie sont des “notions” proposées par des experts mais “refusées”" par d’autres qui effectuent le tagging manuel. On en reste là pour l’analyse de la cohérence des notions, on va passer à la suite mais d’abord…

On supprime les doublons.

match_notions_indic=unique(match_notions_indic[,c("i","tag_id","j")])

Performance des notions

names(tags_ok)
## [1] "i"          "tag_id"     "j"          "notion"     "i.y"       
## [6] "variable"   "value"      "Base"       "Indicateur"
performance_notions_seules=tags_ok%>%
  group_by(variable)%>%
  summarise(nb_positif=sum(value),
         nb_negatif=sum(1-value),
         nb_vrai_positifs=sum(value*!is.na(notion)),
         nb_vrai_negatifs=sum((1-value)*is.na(notion)),
         tvp=nb_vrai_positifs/nb_positif,
         tvn=nb_vrai_negatifs/nb_negatif,
         fscore=(tvp+tvn)/2)%>%
  select(variable,tvp,tvn,fscore)%>%rename(tag=variable)

performance_notions_seules

Agrégation

Ce qui peut sembler surprenant jusque là c’est qu’on a construit une grosse dtm avec tout le vocabulaire sur les indicateurs, mais pour l’apprentissage on pourra se servir uniquement du vocabulaire observé dans les indicateurs taggés !

La motivation est de pouvoir rapidement intégrer les éléments de vocabulaires lorsqu’un nouvel indicateur est taggé, on aura besoin de cette flexibilité pour réaliser l’active learning.

Préparation des objets à agréger

On utilise expand.grid pour produire la table de croisement indicateurs x tags. Vous avez probablement déjà utilisé expand.grid pour réaliser des grid-search dans les cours de machine learning.

nb_ngram_indic <- max(j)
match_notions_indic <- match_notions_indic%>%mutate(id=(tag_id-1)*nb_indicateurs+i)%>%select(-i,-tag_id)
# tags_corres=data.frame(tags=tags,tag_id=1:length(tags))

i2 <- expand.grid(tag_id=1:length(tags),ind_id=i)%>%
  mutate(id=(tag_id-1)*nb_indicateurs+ind_id)%>%.$id
j2 <- expand.grid(tag_id=1:length(tags),j=j)%>%.$j
length(text)==nb_indicateurs
## [1] TRUE
i_tags2 <- expand.grid(tag_id=i_tags,ind_id=1:length(text))%>%mutate(id=(tag_id-1)*nb_indicateurs+ind_id)%>%.$id
j_tags2 <- expand.grid(j_tags=j_tags,ind_id=1:length(text))%>%.$j_tags

j_tags2 <- j_tags2+nb_ngram_indic

i_dimname <- data.frame(i2)%>%distinct%>%.$i2

On vérifie la cohérence. Si tout est à 0 c’est que ça fonctionne

sum(!(unique(i_tags2)%in%i_dimname))
## [1] 0
sum(!(unique(match_notions_indic$id)%in%i_dimname))
## [1] 0
sum(!(unique(i2)%in%i_dimname))
## [1] 0

Génération de la matrice creuse

Et on génère la matrice sparse avec la fonction du package Matrix.

dtm_sp <- sparseMatrix(i=c(i2,i_tags2,
                           match_notions_indic$id),
                       j=c(j2,j_tags2,match_notions_indic$j),
                       dimnames = list(1:max(i_dimname)%>%as.character,
                                       c(dimnm[[2]],
                                         paste0("__",dimnm_tags[[2]]),
                                         "notions")))

Taille des objets

On compare la taille des différents objets

object.size(dtm_sp)
## 220981736 bytes
object.size(i2)+object.size(i_tags2)+object.size(match_notions_indic$id)
## 351964864 bytes
object.size(j2)+object.size(j_tags2)+object.size(match_notions_indic$j)
## 176034168 bytes
object.size(list(1:max(i_dimname)%>%as.character,
              c(dimnm[[2]],paste0("__",dimnm_tags[[2]]),"notions")))
## 44873456 bytes

Vérifications

On tire un indicateur au hasard et on vérifie sa cohérence.

Pour commencer on vérifie si le tag et l’indicateur sont placés tel qu’on l’a imaginé et si les ngrams sont cohérents.

index_test=sample(max(i2),1)
data2[data2$index==index_test%%nb_indicateurs,]$Indicateur
## [1] "taux salariés exposés moins produit chimique 10h plus semaine, sexe secteur activité privé"
tags[(index_test-1)%/%nb_indicateurs+1]# le tag associé
## [1] "habitudes_de_vie_et_addictions"
i_variantes=as.character(0:(length(tags)-1)*nb_indicateurs+index_test%%nb_indicateurs)
i_variantes%in%dimnames(dtm_sp)[[1]]#ces index existent-ils dans la dtm ?
##  [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [15] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [29] TRUE TRUE TRUE TRUE TRUE TRUE TRUE
ngrams=dtm_sp[index_test,]
ngrams=names(ngrams[ngrams])
ngrams # les ngrams de l'indicateur x tag
##  [1] "chimique_10h_plus"                "chimique_10h"                    
##  [3] "produire_chimique_10h"            "10h_plus_semaine"                
##  [5] "10h_plus"                         "10h"                             
##  [7] "semaine_sexe_secteur"             "moins_produire_chimique"         
##  [9] "priver_risque_chimique"           "priver_risque"                   
## [11] "produire_chimique"                "activite_priver_risque"          
## [13] "exposer_moins_produire"           "moins_produire"                  
## [15] "plus_semaine_sexe"                "semaine_sexe"                    
## [17] "salarier_exposer_moins"           "exposer_moins"                   
## [19] "taux_salarier_exposer"            "plus_semaine"                    
## [21] "salarier_exposer"                 "exposer"                         
## [23] "biologique_enquete_surveillance"  "chimique_biologique_risquer"     
## [25] "biologique_risquer"               "professionnel_risque_chimique"   
## [27] "biologique_enquete"               "chimique_biologique_enquete"     
## [29] "biologique_risquer_professionnel" "semaine"                         
## [31] "chimique_biologique"              "risque_chimique"                 
## [33] "risque_chimique_biologique"       "biologique"                      
## [35] "sexe_secteur"                     "sexe_secteur_activite"           
## [37] "secteur_activite_priver"          "professionnel_risque"            
## [39] "risquer_professionnel_risque"     "secteur_activite"                
## [41] "activite_priver"                  "chimique"                        
## [43] "tau_taux_salarier"                "taux_salarier"                   
## [45] "risquer_professionnel"            "enquete_sumer"                   
## [47] "surveillance_medicale"            "risque_professionnel_enquete"    
## [49] "dares_dgt"                        "medicale_exposition"             
## [51] "surveillance_medicale_exposition" "professionnel_enquete_sumer"     
## [53] "dgt_dgafp"                        "dgafp"                           
## [55] "sumer_dares"                      "professionnel_enquete"           
## [57] "salarier_risque_professionnel"    "exposition_salarier_risque"      
## [59] "exposition_salarier"              "enquete_sumer_dares"             
## [61] "sumer"                            "enquete_surveillance_medicale"   
## [63] "salarier_risque"                  "medicale_exposition_salarier"    
## [65] "dares_dgt_dgafp"                  "dgt"                             
## [67] "sumer_dares_dgt"                  "enquete_surveillance"            
## [69] "exposition"                       "dares"                           
## [71] "risque_professionnel"             "surveillance"                    
## [73] "produire"                         "salarier"                        
## [75] "medicale"                         "priver"                          
## [77] "moins"                            "risque"                          
## [79] "plus"                             "risquer"                         
## [81] "secteur"                          "enquete"                         
## [83] "sexe"                             "activite"                        
## [85] "professionnel"                    "tau_taux"                        
## [87] "tau"                              "taux"                            
## [89] "__habitudes_vie_addictions"

Ensuite on vérifie les notions présentes dans cet indicateur

dtm_sp[index_test,"notions"]
## [1] FALSE
dtm_sp[i_variantes,"notions"]
##  13165  32050  50935  69820  88705 107590 126475 145360 164245 183130 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 202015 220900 239785 258670 277555 296440 315325 334210 353095 371980 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 390865 409750 428635 447520 466405 485290 504175 523060 541945 560830 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 579715 598600 617485 636370 655255 
##  FALSE  FALSE  FALSE  FALSE  FALSE
data2[data2$index==index_test%%nb_indicateurs,]$Indicateur
## [1] "taux salariés exposés moins produit chimique 10h plus semaine, sexe secteur activité privé"
tags[dtm_sp[i_variantes,"notions"]]
## character(0)

Machine Learning

[Prélude] Heuristiques pour le tagging

Pour l’instant on va seulement distinguer les indicateurs déjà taggés des autres et on va utiliser des distances sur chaînes de caractères pour labelliser par k-plus proches voisins.

Fréquence des tags par producteur

On vérifie la fréquence de tags par producteurs, on pourra faire de même pour toutes les autres variables catégorielles source, base, famille…

L’idée sous-jacente est qu’il est possible/probable que certains producteurs

indicateur_wtags=data2%>%select(index, Indicateur, Famille,Base, producteur_acronyme)

indicateur_wtags=merge(indicateur_wtags,tagged,by="index",all.x=T)
indicateur_wtags$is_tagged=!is.na(indicateur_wtags$population_generale)
nm_tags=setdiff(names(tagged),"index")
indicateur_wtags=data.table(indicateur_wtags)
stats=na.omit(indicateur_wtags)[,c(nm_tags,"producteur_acronyme"),with=F][,c(lapply(.SD,mean,na.rm=T),.N),by="producteur_acronyme"]
stats

Proximité entre noms d’indicateurs

Cosine

On commence par récupérer les vecteurs d’indicateurs et indices taggés/non-taggés.

table(indicateur_wtags$Base,indicateur_wtags$is_tagged)
##                                         
##                                          FALSE TRUE
##   ameli                                   3233  255
##   atlas santé mentale france (atlasanté)     0  228
##   balises                                   16  964
##   base cépidc                               10  238
##   c@rtosanté                                 0  150
##   data.drees                              4907    4
##   dépistage organisé cancers                 2  178
##   diamant                                  567    0
##   etats financiers (ars)                     5  247
##   hospidiag                                165   16
##   hospitalisations brûlures                  2   38
##   indicateurs inca                           0  674
##   maladies déclaration obligatoire           0   54
##   mortalité traumatismes                     0   84
##   observatoire fragilités grand nord       133   15
##   observatoire fragilités grand sud        148   80
##   odicer                                     0  678
##   pqe at-mp                                  3   50
##   pqe invalidité                             3   61
##   pqe maladie                               23  246
##   scansanté                                140 1051
##   scopesante                                 0  345
##   score santé                             2892  129
##   sirsépaca                                677   66
##   sumer                                      0  188
sub_index=indicateur_wtags[Base=="scansanté"]$index%>%as.character()
tagged_index=indicateur_wtags[index%in%sub_index&is_tagged]$index%>%as.character()
tagged_indicateurs=indicateur_wtags[index%in%sub_index&is_tagged]$Indicateur

to_tag_index=indicateur_wtags[index%in%sub_index&!is_tagged]$index%>%as.character()
to_tag_indicateurs=indicateur_wtags[index%in%sub_index&!is_tagged]$Indicateur

La matrice risque de ne pas tenir en RAM (plusieurs Gb), dans ce cas prenez un échantillon de dtm, par exemple on peut raisonner base par base, ou producteur par producteur.

i_sub=summary(dtm[sub_index,])$i
j_sub=summary(dtm[sub_index,])$j
dimnm_sub=dimnames(dtm[sub_index,])

dt_dtm=simple_triplet_matrix(i = i_sub, j=j_sub, v=rep(1,length(j_sub)), dimnames = dimnm_sub)
# sum(dt_dtm[sample(ncol(dt_dtm)*nrow(dt_dtm),10000)])

On calcule manuellement la matrice de similarité cosine

similarity=tcrossprod_simple_triplet_matrix(dt_dtm)
similarity[1:10,1:10]
##      7713 7714 7715 7716 7717 7718 7719 7720 7721 7722
## 7713   31   31   26   26   26   26   28   28   20   18
## 7714   31   37   26   26   26   26   28   28   20   18
## 7715   26   26   36   34   27   32   28   28   19   18
## 7716   26   26   34   35   27   32   27   27   19   18
## 7717   26   26   27   27   34   27   27   27   19   18
## 7718   26   26   32   32   27   35   27   27   19   18
## 7719   28   28   28   27   27   27   31   30   19   18
## 7720   28   28   28   27   27   27   30   37   19   18
## 7721   20   20   19   19   19   19   19   19   39   30
## 7722   18   18   18   18   18   18   18   18   30   55
summary(c(similarity))
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##  0.000000  3.000000  5.000000  9.507469 13.000000 79.000000

Il faut normaliser la matrice, cette étape est facultative parce que la version non normalisée est déjà exploitable.

diag_=diag(similarity)
diag_[1:10]
## 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 
##   31   37   36   35   34   35   31   37   39   55
diag_=simple_triplet_diag_matrix(sqrt(1/diag_))
dimnames(diag_) <- list(dimnm_sub[[1]],dimnm_sub[[1]])
# diag_ * similarity * diag_
similarity=slam::matprod_simple_triplet_matrix(diag_,similarity)
similarity[1:10,1:10]
##             7713        7714        7715        7716        7717
## 7713 5.567764363 5.567764363 4.669737853 4.669737853 4.669737853
## 7714 5.096368606 6.082762530 4.274373670 4.274373670 4.274373670
## 7715 4.333333333 4.333333333 6.000000000 5.666666667 4.500000000
## 7716 4.394802125 4.394802125 5.747048932 5.916079783 4.563832976
## 7717 4.458963214 4.458963214 4.630461799 4.630461799 5.830951895
## 7718 4.394802125 4.394802125 5.408987230 5.408987230 4.563832976
## 7719 5.028948457 5.028948457 5.028948457 4.849343155 4.849343155
## 7720 4.603171645 4.603171645 4.603171645 4.438772657 4.438772657
## 7721 3.202563076 3.202563076 3.042434922 3.042434922 3.042434922
## 7722 2.427119505 2.427119505 2.427119505 2.427119505 2.427119505
##             7718        7719        7720        7721        7722
## 7713 4.669737853 5.028948457 5.028948457 3.592106041 3.232895436
## 7714 4.274373670 4.603171645 4.603171645 3.287979746 2.959181771
## 7715 5.333333333 4.666666667 4.666666667 3.166666667 3.000000000
## 7716 5.408987230 4.563832976 4.563832976 3.211586168 3.042555317
## 7717 4.630461799 4.630461799 4.630461799 3.258473118 3.086974533
## 7718 5.916079783 4.563832976 4.563832976 3.211586168 3.042555317
## 7719 4.849343155 5.567764363 5.388159061 3.412500739 3.232895436
## 7720 4.438772657 4.931969619 6.082762530 3.123580759 2.959181771
## 7721 3.042434922 3.042434922 3.042434922 6.244997998 4.803844614
## 7722 2.427119505 2.427119505 2.427119505 4.045199175 7.416198487
similarity=slam::matprod_simple_triplet_matrix(similarity,diag_)
similarity[1:10,1:10]
##              7713         7714         7715         7716         7717
## 7713 1.0000000000 0.9153348228 0.7782896421 0.7893297629 0.8008534347
## 7714 0.9153348228 1.0000000000 0.7123956117 0.7225010187 0.7330490368
## 7715 0.7782896421 0.7123956117 1.0000000000 0.9578414887 0.7717436331
## 7716 0.7893297629 0.7225010187 0.9578414887 1.0000000000 0.7826908981
## 7717 0.8008534347 0.7330490368 0.7717436331 0.7826908981 1.0000000000
## 7718 0.7893297629 0.7225010187 0.9014978717 0.9142857143 0.7826908981
## 7719 0.9032258065 0.8267540335 0.8381580761 0.8196886000 0.8316554899
## 7720 0.8267540335 0.7567567568 0.7671952741 0.7502895194 0.7612432305
## 7721 0.5751973085 0.5264981265 0.5070724870 0.5142653639 0.5217732846
## 7722 0.4359235317 0.3990159887 0.4045199175 0.4102580753 0.4162475611
##              7718         7719         7720         7721         7722
## 7713 0.7893297629 0.9032258065 0.8267540335 0.5751973085 0.4359235317
## 7714 0.7225010187 0.8267540335 0.7567567568 0.5264981265 0.3990159887
## 7715 0.9014978717 0.8381580761 0.7671952741 0.5070724870 0.4045199175
## 7716 0.9142857143 0.8196886000 0.7502895194 0.5142653639 0.4102580753
## 7717 0.7826908981 0.8316554899 0.7612432305 0.5217732846 0.4162475611
## 7718 1.0000000000 0.8196886000 0.7502895194 0.5142653639 0.4102580753
## 7719 0.8196886000 1.0000000000 0.8858078930 0.5464374431 0.4359235317
## 7720 0.7502895194 0.8858078930 1.0000000000 0.5001732202 0.3990159887
## 7721 0.5142653639 0.5464374431 0.5001732202 1.0000000000 0.6477502756
## 7722 0.4102580753 0.4359235317 0.3990159887 0.6477502756 1.0000000000
summary(c(similarity))
##       Min.    1st Qu.     Median       Mean    3rd Qu.       Max. 
## 0.00000000 0.05773503 0.10189239 0.18410970 0.26919095 1.00000000

On regarde ce que ça donne sur un exemple. On va cibler les indicateurs non-taggés avec la similarité la plus forte avec des indicateurs déjà taggés.

similarity_in_dataset=rowSums(similarity[to_tag_index,tagged_index])
to=names(which.max(similarity_in_dataset))
indicateur_wtags[index==as.numeric(to)]$Indicateur
## [1] "had - nombre journées présence région"
from=sort(similarity[to,tagged_index],decreasing = T)
from_nm=names(from)
indicateur_wtags[index%in%head(from_nm)]$Indicateur
## [1] "had - nombre journées région"                                       
## [2] "had - nombre journées présence sexe"                                
## [3] "had - nombre journées présence statut juridique"                    
## [4] "had - nombre journées présence hospitalisation complète région"     
## [5] "had - nombre journées présence hospitalisation temps partiel région"
## [6] "had - evolution nombre journées présence région"
indicateur_wtags[index%in%tail(from_nm)]$Indicateur
## [1] "total entrées sorties établissements partenaires mco"                                         
## [2] "sortie transfert (ou des) établissement(s) sélectionné(s) vers établisssments partenaires ssr"
## [3] "densité population (hab/km2)"                                                                 
## [4] "part personnes moins 20 ans (%)"                                                              
## [5] "part personnes plus 75 ans (%)"                                                               
## [6] "evolution population depuis 2008 (%)"

On applique cette logique à tous les indicateurs à tagger.

similarity2=similarity[to_tag_index,tagged_index]
similarity2[1:10,1:10]
##               7713          7714          7715          7716          7717
## 7739 0.39794191946 0.36425009633 0.36927447294 0.37451267036 0.37998029783
## 7814 0.39349550147 0.36018013511 0.36514837167 0.37032803991 0.37573457465
## 7815 0.39349550147 0.36018013511 0.36514837167 0.37032803991 0.37573457465
## 7816 0.42268197221 0.38689552813 0.39223227028 0.39779612648 0.40360367640
## 7975 0.05296271413 0.04847861656 0.02457365936 0.02492223931 0.02528608687
## 7976 0.02514977274 0.04604092555 0.02333800140 0.02366905342 0.02401460532
## 7977 0.02540002540 0.04649905550 0.02357022604 0.02390457219 0.02425356250
## 7978 0.02540002540 0.04649905550 0.02357022604 0.02390457219 0.02425356250
## 7979 0.02514977274 0.02302046278 0.02333800140 0.02366905342 0.02401460532
## 7980 0.02619812585 0.02398005689 0.02431083192 0.02465568364 0.02501563966
##               7718          7719          7720          7721          7722
## 7739 0.37451267036 0.39794191946 0.36425009633 0.41391867719 0.34855071841
## 7814 0.37032803991 0.39349550147 0.36018013511 0.43852900965 0.39389277113
## 7815 0.37032803991 0.39349550147 0.36018013511 0.43852900965 0.39389277113
## 7816 0.39779612648 0.42268197221 0.38689552813 0.47105571977 0.39666441401
## 7975 0.02492223931 0.02648135707 0.02423930828 0.07082882470 0.05964320794
## 7976 0.02366905342 0.02514977274 0.02302046278 0.04484485293 0.05664411840
## 7977 0.02390457219 0.02540002540 0.02324952775 0.04529108137 0.05720775535
## 7978 0.02390457219 0.02540002540 0.02324952775 0.04529108137 0.05720775535
## 7979 0.02366905342 0.02514977274 0.02302046278 0.04484485293 0.05664411840
## 7980 0.02465568364 0.02619812585 0.02398005689 0.04671418359 0.05900529432
order_sim=apply(similarity2,1,order,decreasing=T)%>%t

nb_cols=length(tagged_index)
similarity3=matrix(tagged_indicateurs[order_sim],ncol = nb_cols)
# Les 5 plus ressemblants et les 5 plus dissemblants
similarity3=similarity3[,c(1:5,(nb_cols-4):nb_cols)]
rownames(similarity3) <- to_tag_indicateurs
# View(t(similarity3))
t(similarity3)[,1:5]
##       dont cmp ouverts ? 5j / semaine ambulatoire selon psy. générale psy. infanto-juvénile              
##  [1,] "nombre cattp ambulatoire selon psy. générale psy. infanto-juvénile"                               
##  [2,] "nombre cmp unités consultations ambulatoire selon psy. générale psy. infanto-juvénile"            
##  [3,] "nombre de structures ambulatoire selon psy. générale psy. infanto-juvénile"                       
##  [4,] "nombre structures ateliers thérapeutiques temps partiel selon psy. générale psy. infanto-juvénile"
##  [5,] "nombre places hdj temps partiel selon psy. générale psy. infanto-juvénile"                        
##  [6,] "had - part nombre journées 20 premiers gme hospitalisation temps partiel"                         
##  [7,] "had - age moyen patients 20 premiers gme hospitalisation temps partiel"                           
##  [8,] "had - dépendance physique moyenne 20 premiers gme hospitalisation temps partiel"                  
##  [9,] "had - dépendance cognitive moyenne 20 premiers gme hospitalisation temps partiel"                 
## [10,] "had - score réadaptation rééducation moyen 20 premiers gme hospitalisation temps partiel"         
##       psy recettes daf                                                                     
##  [1,] "nombre venues une journée"                                                          
##  [2,] "nombre actes edga"                                                                  
##  [3,] "psy nombre patients soins consentement*"                                            
##  [4,] "psy pourcentage patients non originaires zone géographique implantation sélectionné"
##  [5,] "psy nombre journées présence temps complet"                                         
##  [6,] "variation annuelle moyenne population période 5 ans (%)"                            
##  [7,] "taux bénéficiaires cmu-c (tous régimes. 2015. fonds cmu)"                           
##  [8,] "densité médecins généralistes spécialistes libéraux 100 000 habitants (2015, drees)"
##  [9,] "population classe âge 1er janvier 2015 (estimation p)"                              
## [10,] "part population classe âge 2015"                                                    
##       psy détail recettes daf                                                              
##  [1,] "nombre venues une journée"                                                          
##  [2,] "nombre actes edga"                                                                  
##  [3,] "psy nombre patients soins consentement*"                                            
##  [4,] "psy pourcentage patients non originaires zone géographique implantation sélectionné"
##  [5,] "psy nombre journées présence temps complet"                                         
##  [6,] "variation annuelle moyenne population période 5 ans (%)"                            
##  [7,] "taux bénéficiaires cmu-c (tous régimes. 2015. fonds cmu)"                           
##  [8,] "densité médecins généralistes spécialistes libéraux 100 000 habitants (2015, drees)"
##  [9,] "population classe âge 1er janvier 2015 (estimation p)"                              
## [10,] "part population classe âge 2015"                                                    
##       psy recettes oqn                                                                          
##  [1,] "nombre venues une journée"                                                               
##  [2,] "nombre actes edga"                                                                       
##  [3,] "psy nombre patients soins consentement*"                                                 
##  [4,] "psy pourcentage patients non originaires zone géographique implantation sélectionné"     
##  [5,] "psy nombre journées présence temps complet"                                              
##  [6,] "had - part nombre journées 20 premiers gme hospitalisation temps partiel"                
##  [7,] "had - age moyen patients 20 premiers gme hospitalisation temps partiel"                  
##  [8,] "had - dépendance physique moyenne 20 premiers gme hospitalisation temps partiel"         
##  [9,] "had - dépendance cognitive moyenne 20 premiers gme hospitalisation temps partiel"        
## [10,] "had - score réadaptation rééducation moyen 20 premiers gme hospitalisation temps partiel"
##       had nombre journées période selon "" patients domiciliés département"" ""établissements département""
##  [1,] "ssr nombre journées (hc hp séances)"                                                                
##  [2,] "ssr avq relationnel moyen"                                                                          
##  [3,] "ssr nombre moy actes csarr journée"                                                                 
##  [4,] "mco proportion malades masculins période type activité"                                             
##  [5,] "ssr sexe ratio (% homme)"                                                                           
##  [6,] "population 1er janvier"                                                                             
##  [7,] "taux bénéficiaires cmu-c (tous régimes. 2015. fonds cmu)"                                           
##  [8,] "densité médecins généralistes spécialistes libéraux 100 000 habitants (2015, drees)"                
##  [9,] "population classe âge 1er janvier 2015 (estimation p)"                                              
## [10,] "part population classe âge 2015"

Pour aller plus loin on pourrait mettre un seuil de similarité sur les indicateurs et utiliser les tags déjà appliqués pour prédire le tag.

to
## [1] "8693"
from_best=from[from>.7]
freq_tags=indicateur_wtags[index%in%as.numeric(names(from_best)),nm_tags,with=F]%>%colSums()/length(from_best)
sort(freq_tags,decreasing = T)
##                                          population_generale 
##                                                  1.000000000 
##                                            recours_aux_soins 
##                                                  1.000000000 
##                                      coordination_continuite 
##                                                  0.131147541 
##                                              personnes_agees 
##                                                  0.000000000 
##                         enfants__adolescents__jeunes_adultes 
##                                                  0.000000000 
##                                          population_precaire 
##                                                  0.000000000 
##                                        personnes_handicapees 
##                                                  0.000000000 
##                                sante_des_femmes_perinatalite 
##                                                  0.000000000 
##                    diabete_et_autres_maladies_endocriniennes 
##                                                  0.000000000 
##                                                sante_mentale 
##                                                  0.000000000 
##                                                       cancer 
##                                                  0.000000000 
##                        maladie_de_l_appareil_genito_urinaire 
##                                                  0.000000000 
##                                   maladies_cardiovasculaires 
##                                                  0.000000000 
##                      maladies_neurologiques_ou_degeneratives 
##                                                  0.000000000 
##                                       maladies_respiratoires 
##                                                  0.000000000 
##                              maladies_de_l_appareil_digestif 
##                                                  0.000000000 
##                                        maladies_infectieuses 
##                                                  0.000000000 
##                     pathologies_du_systeme_osteo_articulaire 
##                                                  0.000000000 
##                    traumatismes_et_pathologies_accidentelles 
##                                                  0.000000000 
##                                           autres_pathologies 
##                                                  0.000000000 
##                                qualite_et_securite_des_soins 
##                                                  0.000000000 
##                                         prevention_depistage 
##                                                  0.000000000 
##                  accessibilite_geographique_financier_autres 
##                                                  0.000000000 
##                               habitudes_de_vie_et_addictions 
##                                                  0.000000000 
##                                determinants_environnementaux 
##                                                  0.000000000 
##                               e_sante_systemes_d_information 
##                                                  0.000000000 
##                        droits_d_usagers_democratie_sanitaire 
##                                                  0.000000000 
## mesures_d_inegalites_et_de_disparites_territoriales_de_sante 
##                                                  0.000000000 
##                   contexte_demographique_et_socio_economique 
##                                                  0.000000000 
##                                               offre_de_soins 
##                                                  0.000000000 
##                                         offre_medico_sociale 
##                                                  0.000000000 
##                                           protection_sociale 
##                                                  0.000000000 
##                                            depenses_de_sante 
##                                                  0.000000000 
##                                                etat_de_sante 
##                                                  0.000000000 
##                                  determinants_professionnels 
##                                                  0.000000000

Ca a l’air de plutôt bien fonctionner… On en reste là pour cet technique de généralisation.

[Exercice] Distances entre strings

On a calculé “manuellement” les similarités cosine, maintenant utilisez le package stringdist pour calculer des distances entre les noms des indicateurs. Par exemple on pourra utiliser la fonction amatch

# A VOUS DE JOUER
methods=c("osa",
"lv",
"dl",
"hamming",
"lcs",
"qgram",
"cosine",
"jaccard",
"jw",
"soundex")

On va maintenant passer à l’étape de construction du modèle de généralisation du tagging avec séparation des données en échantillons d’entraînement et de test.

Préparation

Echantillonnage train-test

On échantillonne sur les indicateurs et non directement sur les couples indicateurs x tags.

train_smp=sample(tagged_ids,size = round(.75*length(tagged_ids)))
test_smp = setdiff(tagged_ids, train_smp)
train_ind=rowSums(expand.grid((1:length(tags)-1)*nb_indicateurs,train_smp))
test_ind=rowSums(expand.grid((1:length(tags)-1)*nb_indicateurs,test_smp))

Bases de train-test

On va sélectionner uniquement les colonnes pertinentes pour l’apprentissage pour ça on a recours à colSums pour vérifier si les colonnes sont constantes égales à 0.

Remarque : Cette pratique nous donne une piste pour l’active learning, on pourra demander au métier de tagger en priorité les indicateurs les moins bien représentés par le vocabulaire actuellement taggé

ngrams_tagged <- which(colSums(dtm_sp[c(train_ind,test_ind),])>0)
  knowns_ind <- tagged_triplet[tagged_triplet$id%in%train_ind,][['i']] 
  train_ind <- train_ind[train_ind%in%knowns_ind]
  train_ind <- sort(train_ind)
  train_labels <- tagged_triplet[tagged_triplet$id%in%train_ind,]%>%
    arrange(i)%>%.[['value']]
  train_dtm <- dtm_sp[train_ind,ngrams_tagged]
  dtrain <- xgb.DMatrix(data = as(train_dtm,"dgCMatrix"), 
                        label = train_labels)
  ## Même chose pour le test qui va aussi nous servir de validation ici parce qu'on ne fait pas de gridsearch.
  knowns_ind <- tagged_triplet[tagged_triplet$id%in%test_ind,][['i']] 
  test_ind <- test_ind[test_ind%in%knowns_ind]
  test_ind <- sort(test_ind)
  test_labels <- tagged_triplet[tagged_triplet$id%in%test_ind,]%>%
    arrange(i)%>%.[['value']]
  test_dtm <- dtm_sp[test_ind,ngrams_tagged]
  dtest <- xgb.DMatrix(data = as(test_dtm,"dgCMatrix"), 
                        label = test_labels)
  watchlist <- list(train = dtrain,eval = dtest)

Entraînement

On propose deux stratégies d’apprentissage, la première slow robuste et lente pour le modèle final, la seconde fast est plus rapide et “suffisante” pour évaluer le modèle régulièrement, une dernière superfast cherche à se rapprocher de l’instantanéité pour faire de l’active learning mais concrètement c’est difficile une fois qu’on n’est plus sur qqcentaines d’indicateurs taggés mais qqmilliers alors on se contente de 10-30 secondes.

timing="superfast"
if (timing=="slow"){
params=list(eta=.1,
            max_depth=6,
            min_child_weight=5,
            subsample=500*length(tags)/length(train_ind),
            colsample_bytree=8000/length(ngrams_tagged),
            objective="binary:logistic",
            eval_metric="auc",
            gamma=.01)
nrounds=5E+3
} else if (timing=="fast"){
  params=list(eta=.2,
              max_depth=6,
              min_child_weight=1,
              subsample=500*length(tags)/length(train_ind),
              colsample_bytree=1000/length(ngrams_tagged),
              objective="binary:logistic",
              eval_metric="auc",
              gamma=.01)
  nrounds=2E+2
} else if (timing=="superfast"){
  params=list(eta=.1,
              max_depth=3,
              min_child_weight=1,
              subsample=500*length(tags)/length(train_ind),
              colsample_bytree=5000/length(ngrams_tagged),
              objective="binary:logistic",
              eval_metric="auc",
              gamma=.01)
  nrounds=1E+2
}

On lance xgboost. Je vous invite à prendre le temps jouer sur les différentes paramètres, un gridsearch greedy sera trop long parce que chaque itération dure 30, 60, 120 secondes… mais essayer de jouer avec les paramètres 1 à 1 pour comprendre ce qui se passe.

Par exemple, on remarquera que le choix du colsample_bytree est décisif.

system.time(xgbmodel <- xgb.train(params = params,dtrain,
                                  verbose = 1,print_every_n = 10,
                                  nrounds = nrounds,watchlist,
                                  early_stopping_rounds=200))
save(xgbmodel,file="trained_model.RData")
load("trained_model.RData")

Analyse des résultats

Importance des variables (ngrams)

Les ngrams précédés de __ sont ceux relatifs aux tags.

Le feature notions est la variable générée à partir du dictionnaire des notions. Elle devrait fonctionner à tous les coups mais on a vu que ce n’est pas toujours le cas.

  • Gain contribution of each feature to the model. For boosted tree model, each gain of each feature of each tree is taken into account, then average per feature to give a vision of the entire model. Highest percentage means important feature to predict the label used for the training (only available for tree models);

  • Cover metric of the number of observation related to this feature (only available for tree models);

  • Weight percentage representing the relative number of times a feature have been taken into trees.

imp=xgb.importance(feature_names = NULL,xgbmodel)
head(imp,30)

Ngrams les plus importants par indicateur

get_imp_ngrams=data.table(i=i,j=j)
dico_ngrams=data.frame(j=1:max(j),ngram=dimnm[[2]])
get_imp_ngrams=merge(get_imp_ngrams,dico_ngrams,by="j")

get_imp_ngrams=merge(get_imp_ngrams,imp,by.x="ngram",by.y="Feature")

setorder(get_imp_ngrams,-Gain)
get_imp_ngrams[,order:=1:.N,by="i"]
get_imp_ngrams=get_imp_ngrams[order<=10]

get_imp_ngrams=dcast(get_imp_ngrams,i~order,value.var="ngram")

get_imp_ngrams=merge(get_imp_ngrams,data2[,c("index","Indicateur")],by.x="i",by.y="index")

sample_n(get_imp_ngrams%>%select(-i),10)

On remarque que des stopwords nous ont échappé… mais manifestement ils n’étaient pas si “creux” puisque le modèle les a retenu.

Si on voit les choses autrement, on peut se dire que lorsque le ngram influent est un stopwords, les autres ngrams moins influents ne sont probablement pas pertinent. De plus si LE ngram le plus influent est un stopword, alors l’indicateur est probablement mal taggé…

Prédiction

Séparation des indicateurs non taggés

On construit la liste des indices des indicateurs dans la dtm qui sont déjà taggés et ne nécessitent donc pas de prédiction pour l’active learning.

Pour illustrer le contenu de cet objet, on fournit la liste des indices associés à l’indicateur numéro 8990 pour chaque couple indicateur x tag.

done_id=unique(c(test_ind,train_ind)%%nb_indicateurs)
max(done_id)
## [1] 14350
done_id=expand.grid((0:(length(tags)-1)*nb_indicateurs),done_id)%>%{.$Var1+.$Var2}
done_id%>%{.[.%%nb_indicateurs==8990]}
##  [1]   8990  27875  46760  65645  84530 103415 122300 141185 160070 178955
## [11] 197840 216725 235610 254495 273380 292265 311150 330035 348920 367805
## [21] 386690 405575 424460 443345 462230 481115 500000 518885 537770 556655
## [31] 575540 594425 613310 632195 651080

Puis on extrait la dtm des indicateurs non taggés.

untagged_dtm=dtm_sp[setdiff(dimnames(dtm_sp)[[1]],as.character(done_id)),
                    ngrams_tagged]

On vérifie qu’on retrouve bien tous nos 35 tags et que chaque tag a le même nombre d’indicateur. Lorsqu’on manipule les donner dans tous les sens il faut régulièrement vérifier qu’on n’a pas fait n’importe quoi.

table((as.numeric(dimnames(untagged_dtm)[[1]])-1)%/%nb_indicateurs)
## 
##     0     1     2     3     4     5     6     7     8     9    10    11 
## 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 
##    12    13    14    15    16    17    18    19    20    21    22    23 
## 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 
##    24    25    26    27    28    29    30    31    32    33    34 
## 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926 12926

Prédiction pour les indicateurs non taggés

Le temps de prédiction dépend linéairement du nombre d’arbre dans le modèle, d’où le besoin de limiter le nombre d’arbres.

system.time(prediction <- predict(object=xgbmodel,
                        newdata = as(untagged_dtm,"dgCMatrix")))
##    user  system elapsed 
##    1.99    0.19    1.68
pred <- data.frame(id=as.numeric(dimnames(untagged_dtm)[[1]]),
                   pred=prediction,notion=untagged_dtm[,"notions"])
pred=data.table(pred)

On va hacker les predictions avec les notions. La variable notion est déjà codée TRUE/FALSE qui deviendra 1/0 par coercion en numérique, on peut donc la voir comme une proba/prédiction. On remarquera le recours à pmax pour le max sur les lignes.

pred$pred=pmax(pred$pred,pred$notion)

Pour l’instant on a ça :

head(pred)

Ces IDs ne sont pas très exploitables, on veut récupérer l’index du tag et de l’indicateur puis les noms des tags et indicateurs.

pred$tag_id=1+(as.numeric(as.character(pred$id))-1)%/%nb_indicateurs
pred$indic_id=1+(as.numeric(as.character(pred$id))-1)%%nb_indicateurs
nb_indicateurs_a_tagger=uniqueN(pred$indic_id)
nb_indicateurs_a_tagger
## [1] 12926

Maintenant on a ça :

head(pred)
pred=merge(pred,tags_corres,by="tag_id")

On ordonne pred par valeur de prediction puis par indicateur. Ainsi on pourra aisément récupérer les tags “favoris”

setorder(pred,-pred,indic_id)
pred$tags=as.character(pred$tags)

Proba => Décision

Seuil sur la fréquence réelle (empirique)

On va calculer la fréquence réelle des tags dans la base puis la comparer avec la prédiction moyenne.

freq_tags=tagged_triplet[,list(frequence=mean(value)),by="variable"]
pred_with_freq=merge(pred,freq_tags,by.x="tags",by.y="variable")
nrow(pred_with_freq)/nrow(pred)# Si 1, alors jointure OK, sinon il y a un pb dans les noms des tags.
## [1] 1
pred_with_freq[,list(pred=mean(pred)),by="tags"]%>%merge(freq_tags,by.x="tags",by.y="variable")%>%View

On observe un décalage important entre prédiction moyenne et fréquence réelle pour certains indicateurs. Pour le moment on utilise les prédictions mais il va falloir “trancher” ie décider quelques tags sont appliqués et quels tags sont refusés ce qui nous donnera une fréquence davantage comparable à la fréquence réelle.

Par exemple si on prenait la décision de retenir les tags lorsque la prédiction est supérieure à X% de la fréquence empirique, on obtiendrait ces répartitions.

pred_with_freq[,list("nb_tags_applied"=mean(pred>frequence*.9)),by="tags"]%>%
  merge(freq_tags,by.x="tags",by.y="variable")%>%
  mutate(ratio=nb_tags_applied/frequence)%>%
  {ggplot(.,aes(x=tags,label=ratio))+
      geom_point(aes(y=nb_tags_applied),color="red")+
      geom_point(aes(y=frequence),color="blue")+
      theme(axis.text.x = element_blank())}%>%ggplotly

Cette stratégie n’est pas très satisfaisante dans notre cas. On observe des ratios énormes x10, voire davantage.

Calage sur marge

Une fois encore on va s’appuyer sur la fréquence réelle et appliquer les tags aux indicateurs de sorte à garantir la cohérence des fréquences. Dans ce cas là c’est la distribution des tags par indicateur qui va nous inquiéter. Le métier nous a indiqué qu’il faudrait au moins 1 tag (la liste a été construite de façon à donner une vue exhaustive des thématiques de la santé) par indicateur et au plus 4-5.

pred_with_freq[,round(frequence*.N,0)[1],by="tags"]
pred_with_freq[,rank:=1:.N,by="tags"]
nb_tags_per_indic=pred_with_freq[rank<=round(frequence*nb_indicateurs_a_tagger,0),
                                 list(nb_tags=.N),by="indic_id"]



hist(nb_tags_per_indic$nb_tags)

table(nb_tags_per_indic$nb_tags)
## 
##    1    2    3    4    5    6    7    8    9   10   11   12   13   14   15 
## 4330 3118 1750  729  473  221  130  169  129  129  155  105   32  102   92 
##   16   17   18   19   20   21   22   23   24   25   26 
##   39   30    7   27   12    8   11   14   22   11    3

Cette méthode ne respecte pas les règles proposées par le métier. On compte des indicateurs avec aucun tag et d’autre avec une vingtaine de tags…

On souhaite comprendre pourquoi les tags sont ainsi distribués, est-ce que notre modèle est biaisé ?

nrow(nb_tags_per_indic)/nrow(pred_with_freq)# fraction des tags possibles attribués
## [1] 0.0261886342
nrow(nb_tags_per_indic)/nb_indicateurs_a_tagger# nombre moyen de tags par indicateur
## [1] 0.9166021971
# nb_tags_per_indic$indic_id[!nb_tags_per_indic$indic_id%in%pred$indic_id]
nb_tags_per_indic=merge(nb_tags_per_indic,data2[,c("index","Indicateur_enriched","Indicateur","Producteur","Producteur de la base")],by.x="indic_id",by.y="index")
setorder(nb_tags_per_indic,-nb_tags)

head(nb_tags_per_indic$Indicateur)
## [1] "taux standardisé admission prématurée ald maladies infectieuses parasitaires (pop. réf. pse 2013) selon sexe"                            
## [2] "taux standardisé admission prématurée ald maladies infectieuses parasitaires (pop. réf. rp 2006) selon sexe"                             
## [3] "taux variation annuel moyen taux standardisé admission prématurée ald maladies infectieuses parasitaires (pop. réf. pse 2013) selon sexe"
## [4] "dépassements auxiliaires medicaux libéraux"                                                                                              
## [5] "honoraires dépassement chirurgiens dentistes libéraux spécialisés médecine bucco-dentaire actifs part entière (ape)"                     
## [6] "honoraires dépassement sages-femmes libérales actifs part entière (ape)"
tail(nb_tags_per_indic$Indicateur)
## [1] "répartition etp secteur pmi centres planification"      
## [2] "répartition etp secteur aide sociale enfance"           
## [3] "répartition etp secteur insertion"                      
## [4] "répartition etp secteur activités polyvalentes"         
## [5] "répartition etp secteur activités générales diverses"   
## [6] "répartition etp personnel action sociale médico-sociale"

On se rend compte que les longs noms d’indicateurs semble davantage taggés, c’est un biais contre lequel on ne peut pas grand chose, notre modèle est basé sur la présence de mots clefs, plus un nom d’indicateur est long plus il peut contenir des mots clefs plus il peut être associé à des tags.

Vérifions cette intuition.

nb_tags_per_indic$nb_lettres_full=nchar(nb_tags_per_indic$Indicateur_enriched)
nb_tags_per_indic$nb_mots_full=str_count(nb_tags_per_indic$Indicateur_enriched," ")+1
nb_tags_per_indic$nb_lettres=nchar(nb_tags_per_indic$Indicateur)
nb_tags_per_indic$nb_mots=str_count(nb_tags_per_indic$Indicateur," ")+1

cor(nb_tags_per_indic[,c("nb_tags","nb_lettres","nb_mots")])
##                  nb_tags    nb_lettres       nb_mots
## nb_tags    1.00000000000 0.03967351207 0.06719575451
## nb_lettres 0.03967351207 1.00000000000 0.95327898753
## nb_mots    0.06719575451 0.95327898753 1.00000000000
cor(nb_tags_per_indic$nb_tags,nb_tags_per_indic$nb_mots,method = "pearson")
## [1] 0.06719575451

Corrélation 5% entre le nombre de tags et le nombre de mots, c’est positif mais faible.

Une autre hypothèse serait la pertinence du nommage par les producteurs, comparrons les taux de tagging par producteur.

stats_per_prod=nb_tags_per_indic[,list(volume=.N,moyenne=mean(nb_tags),decile1=quantile(nb_tags,.1),mediane=quantile(nb_tags,.5),decile9=quantile(nb_tags,.9)),by="Producteur de la base"]
setorder(stats_per_prod,-volume)
head(stats_per_prod,10)
stats_per_prod$num=1:nrow(stats_per_prod)
stats_per_prod$`Producteur de la base`=reorder(stats_per_prod$`Producteur de la base`,-stats_per_prod$volume)
g <- ggplot(stats_per_prod[volume>100],aes(x=`Producteur de la base`,label=volume))+
  geom_bar(aes(y=decile9),stat="identity",fill="#ff0000")+
  geom_bar(aes(y=moyenne),stat="identity",fill="#ff6600")+
  geom_bar(aes(y=mediane),stat="identity",fill="#ff9933")+
  geom_bar(aes(y=decile1),stat="identity",fill="#ffcc00")+
theme(axis.text.x = element_blank(),axis.ticks.x = element_blank())
      
g%>%ggplotly

Entre la DREES, la CNAMTS et la FNORS qui sont les 3 plus gros producteurs, on observe des différences importantes dans le nombre de tags appliqués.

Une hypothèse pourrait être la différence de type d’indicateurs produits par la DREES comparée au reste de l’écosystème. Aucun indicateurs DREES n’étant taggé, il est probablement difficile d’appliquer les tags sur cet échantillon atypique.

Exercice 1 [manipulation de données]

Essayer d’implémenter une allocation qui respecte à la fois

  • la contrainte de cohérence avec les fréquences réelles
  • la contrainte d’allouer entre 1 et 5 tags par indicateur

** solution **

On commence par récupérer le tag favori pour chaque indicateur. Pour cela on crée un classement de tags par indicateur, le rank_tag==1 est le favori qu’on devra toujours garder.

setorder(pred_with_freq,-pred)
pred_with_freq[,rank_tag:=1:.N,by="indic_id"]
pred_with_freq[,"nombre_a_allouer":=frequence*nb_indicateurs_a_tagger]
pred_with_freq[rank_tag==1,"deja_alloue_top1":=.N,by="tags"]
pred_with_freq[is.na(deja_alloue_top1),deja_alloue_top1:=0]
favori=pred_with_freq[rank_tag==1]
reste=pred_with_freq[rank_tag>1&rank_tag<=5]
reste=reste[rank<=nombre_a_allouer-deja_alloue_top1]
choix_pred=rbind(favori,reste)

On vérifie la fréquence des tags

choix_pred[,list(nb_tags_applied=.N/nb_indicateurs_a_tagger,frequence=frequence[1]),by="tags"]%>%
mutate(ratio=nb_tags_applied/frequence)%>%
  {ggplot(.,aes(x=tags,label=ratio))+
      geom_point(aes(y=nb_tags_applied),color="red")+
      geom_point(aes(y=frequence),color="blue")+
      theme(axis.text.x = element_blank())}%>%ggplotly
choix_pred=merge(choix_pred,data2[,c("index","Indicateur_enriched","Indicateur","Producteur","Producteur de la base")],by.x="indic_id",by.y="index")

On vérifie la distribution des tags par indicateur

setnames(choix_pred,"Producteur de la base","Producteur_de_la_base")
stats_per_prod=choix_pred[
  ,list(nb_tags=.N,"Producteur_de_la_base"=Producteur_de_la_base[1]),
  by="indic_id"]
table(stats_per_prod$nb_tags)
## 
##    1    2    3    4    5 
## 4888 2858 2907 1322  951
stats_per_prod=stats_per_prod[ ,list(volume=.N,
        moyenne=mean(nb_tags),
        decile1=quantile(nb_tags,.1),
        mediane=quantile(nb_tags,.5),
        decile9=quantile(nb_tags,.9)),
  by="Producteur_de_la_base"]

setorder(stats_per_prod,-volume)
head(stats_per_prod,10)
stats_per_prod$num=1:nrow(stats_per_prod)
stats_per_prod$Producteur_de_la_base=reorder(stats_per_prod$Producteur_de_la_base,-stats_per_prod$volume)
g <- ggplot(stats_per_prod[volume>100],aes(x=Producteur_de_la_base,label=volume))+
  geom_bar(aes(y=decile9),stat="identity",fill="#ff0000")+
  geom_bar(aes(y=moyenne),stat="identity",fill="#ff6600")+
  geom_bar(aes(y=mediane),stat="identity",fill="#ff9933")+
  geom_bar(aes(y=decile1),stat="identity",fill="#ffcc00")+
theme(axis.text.x = element_blank(),axis.ticks.x = element_blank())
      
g%>%ggplotly

Exercice 2 [modélisation]

** Modéliser le nombre de tags à appliquer à un indicateur**

L’avantage de cette démarche est qu’elle peut être appliquée directement sur la dtm des indicateurs sans croisements avec les tags donc 35x moins de lignes… C’est l’occasion d’utiliser tout votre inventaire de modèles sur ce petit jeu de 6000 indicateurs taggés.

A VOUS DE JOUER !

Tirage d’un nombre fixe de tags

indicateurs_pred=pred[,list(tag1=tags[1],
                            prob_tag1=pred[1],
                            tag2=tags[2],
                            prob_tag2=pred[2],
                            tag3=tags[3],
                            prob_tag3=pred[3],
                            tag4=tags[4],
                            prob_tag4=pred[4],
                            tag5=tags[5],
                            prob_tag5=pred[5]
                            # max_prob=max(pred),
                            # min_prob=min(pred),
                            # sum_prob=sum(pred)
                            ),
                      by=c("indic_id")]
table(c(indicateurs_pred$tag1,indicateurs_pred$tag2,indicateurs_pred$tag3,indicateurs_pred$tag4,indicateurs_pred$tag5))
## 
## accessibilite_geographique_financier_autres 
##                                         390 
##                          autres_pathologies 
##                                        2387 
##                                      cancer 
##                                        1016 
##                     coordination_continuite 
##                                         403 
##                           depenses_de_sante 
##                                        2394 
##   diabete_et_autres_maladies_endocriniennes 
##                                           6 
##              e_sante_systemes_d_information 
##                                           5 
##        enfants__adolescents__jeunes_adultes 
##                                         379 
##                               etat_de_sante 
##                                       12781 
##              habitudes_de_vie_et_addictions 
##                                         465 
##                  maladies_cardiovasculaires 
##                                          82 
##             maladies_de_l_appareil_digestif 
##                                         168 
##                       maladies_infectieuses 
##                                         200 
##     maladies_neurologiques_ou_degeneratives 
##                                          69 
##                      maladies_respiratoires 
##                                         244 
##                              offre_de_soins 
##                                         314 
##    pathologies_du_systeme_osteo_articulaire 
##                                         227 
##                             personnes_agees 
##                                         463 
##                       personnes_handicapees 
##                                         497 
##                         population_generale 
##                                       12919 
##                         population_precaire 
##                                         343 
##                        prevention_depistage 
##                                         666 
##                          protection_sociale 
##                                        1007 
##               qualite_et_securite_des_soins 
##                                        7083 
##                           recours_aux_soins 
##                                       12745 
##               sante_des_femmes_perinatalite 
##                                        1813 
##                               sante_mentale 
##                                        5405 
##   traumatismes_et_pathologies_accidentelles 
##                                         159

On apparie avec les données sources

indicateurs_pred=merge(indicateurs_pred,data2,by.x="indic_id",by.y="index")

On peut vérifier visuellement la cohérence des tags avec les ngrams influents.

consistency_imp_word=merge(indicateurs_pred,get_imp_ngrams,by.x="indic_id",by.y="i")
setorder(consistency_imp_word,prob_tag1)
# View(consistency_imp_word)

Active Learning

Les applications shiny sont le support parfait pour créer une application d’active learning à fournir aux usagers métier.

Le squelette

Pour bien faire les choses on décompose l’application en 3 scripts ui.R server.R et global.R.

library(shiny)
runApp(list(
    ui = fluidPage(title = "Tagging des indicateurs",
      shiny::tags$h1("Tagging des indicateurs")
    ),
    server = function(input, output) {
    }
  ))

Le choix des tags

On ajoute une barre de sélection pour que l’utilisateur puisse choisir les tags à appliquer.

runApp(list(
    ui = fluidPage(title = "Tagging des indicateurs", 
            shiny::tags$h1("Tagging des indicateurs"),
            selectizeInput('tags', 'Choix des tags', choices=tags_corres$tags,multiple=T)
    ),
    server = function(input, output) {
    }
  ))

L’indicateur à tagger

Mais avant d’appliquer des tags, il faut que l’utilisateur ait un indicateur à étudier.

### DANS LE global.R
library(DT)
indicateurs_pred$prob_sum=rowSums(indicateurs_pred[,paste0("prob_tag",1:5)])
setorder(indicateurs_pred,prob_sum)
var_a_afficher=c("Base","Indicateur","Famille",
       "Classement producteur Niveau 1 (le moins détaillé)",
       "Classement producteur Niveau 2",
       "Classement producteur Niveau 3 (le plus détaillé)","source_acronyme","producteur_acronyme",paste0("tag",1:5))

# SERVER
servr=function(input, output) {
      output$table=renderDT(datatable(indicateurs_pred[1,var_a_afficher,with=F]))
}
# UI
ui_carto = fluidPage(title = "Tagging des indicateurs", 
            shiny::tags$h1("Tagging des indicateurs"),
            selectizeInput('tags', 'Choix des tags', choices=tags_corres$tags,multiple=T),
            DTOutput("table")
    )

runApp(list(
    ui = ui_carto,
    server = servr
  ))

Ajout d’une sidebar

Pour clarifier l’application on propose un découpage en colonnes afin de bien séparer la partie où l’utilisateur peut agir (choix des tags) de la partie lecture.

# UI
ui_carto = fluidPage(title = "Tagging des indicateurs", 
            sidebarPanel(
              shiny::tags$h1("Choix des tags"),
              selectizeInput('tags', 'Choix multiples parmi 35', choices=tags_corres$tags,multiple=T)),
            mainPanel(
              shiny::tags$h1("L'indicateur à tagger"),
              DTOutput("table"))
    )

runApp(list(
    ui = ui_carto,
    server = servr
  ))

Autres interactions avec l’utilisateur

Ajout d’un bouton de validation, un autre bouton pour passer l’indicateur, un dernier pour relancer le modèle et la prédiction.

On ajoute des icones aux boutons en cherchant dans le catalogue font-awesome

# UI
ui_carto = fluidPage(title = "Tagging des indicateurs", 
            sidebarPanel(
              shiny::tags$h1("Choix des tags"),
              selectizeInput('tags', 'Choix multiples parmi 35',  choices=tags_corres$tags,multiple=T),
              actionButton("submit_tags","Valider",icon=icon("check-circle")),
actionButton("skip","Passer",icon=icon("fast-forward")),
actionButton("rerun","Re-Lancer",icon=icon("cogs"))

              ),
            mainPanel(
              shiny::tags$h1("L'indicateur à tagger"),
              DTOutput("table"))
    )

runApp(list(
    ui = ui_carto,
    server = servr
  ))

Passer l’indicateur

Maintenant on passe à la logique côté serveur, plus complexe à gérer. On va commencer par le plus simple, passer l’indicateur et afficher le suivant. Pour cela on a besoin de gérer une liste d’indicateurs déjà traités (taggés ou passés). Pour cela on aura recours à des reactifs.

# SERVER
servr=function(input, output) {
  index_done=reactiveVal(0)
  output$table=renderDT(datatable(indicateurs_pred[!indic_id%in%index_done()][1,var_a_afficher,with=F]))
  observeEvent(input$skip,{
    curr_index=indicateurs_pred[!indic_id%in%index_done()][1]$indic_id
    print("Ajout à la liste des indices traités")
    print(curr_index)
    index_done(c(index_done(),curr_index))
  })
}


runApp(list(
    ui = ui_carto,
    server = servr
  ))

Valider les tags

Cas de base

On commence par gérer un cas de base important, lorsque l’utilisateur clique sur “valider” sans avoir renseigné de tags.

# SERVER
servr=function(input, output) {
  index_done=reactiveVal(0)
  output$table=renderDT(datatable(indicateurs_pred[!indic_id%in%index_done()][1,var_a_afficher,with=F]))
  observeEvent(input$skip,{
    curr_index=indicateurs_pred[!indic_id%in%index_done()][1]$indic_id
    print("Ajout à la liste des indices traités")
    print(curr_index)
    index_done(c(index_done(),curr_index))
  })
  observeEvent(input$submit_tags,{
    if(length(input$tags)==0){
      showModal(modalDialog(easyClose = T,size = "s",
        title = "Attention",
        "Si vous ne renseignez aucun tag, il est préférable de cliquer sur 'passer' pour passer à l'indicateur suivant sans appliquer de tag à celui-ci"
      ))
    }
  })
  
}


runApp(list(
    ui = ui_carto,
    server = servr
  ))

Enregistrement de l’indicateur taggé

On doit récupérer l’information sur l’indicateur fraîchement taggé et la structurer pour l’ajouter à tagged_triplet. Avant de lancer le code, essayer par vous même, jeter d’abord un oeil à names(tagged_triplet).

# GLOBAL

tagged_triplet_bis=tagged_triplet
# SERVER
servr=function(input, output,session) {
  index_done=reactiveVal(0)
  
  add_tags=reactiveVal(0)
  
  output$table=renderDT(datatable(indicateurs_pred[!indic_id%in%index_done()][1,var_a_afficher,with=F]))
  observeEvent(input$skip,{
    curr_index=indicateurs_pred[!indic_id%in%index_done()][1]$indic_id
    print("Ajout à la liste des indices traités")
    print(curr_index)
    index_done(c(index_done(),curr_index))
  })
  observeEvent(input$submit_tags,{
    if(length(input$tags)==0){
      showModal(modalDialog(easyClose = T,size = "s",
        title = "Attention",
        "Si vous ne renseignez aucun tag, il est préférable de cliquer sur 'passer' pour passer à l'indicateur suivant sans appliquer de tag à celui-ci"
      ))
    } else if (length(input$tags)>0){
      print(input$tags)
      curr_index=indicateurs_pred[!indic_id%in%index_done()][1]$indic_id
      infos_indicateur=indicateurs_pred[!indic_id%in%index_done()][1]%>%select(indic_id,Base,Indicateur)%>%rename(id=indic_id)
      tags_applied=data.table(tags_corres)
      setnames(tags_applied,"tags","variable")#Parce que le tag s'appelle comme ça dans tagged_triplet
      tags_applied$value=0#initialisation
      tags_applied[tags%in%input$tags,value:=1]
      infos_indicateur=cbind(infos_indicateur,tags_applied)
      infos_indicateur$i=infos_indicateur$tag_id*infos_indicateur$id
      index_done(c(index_done(),curr_index))
      print(nrow(tagged_triplet_bis))
      tagged_triplet_bis <<- rbind(tagged_triplet_bis,infos_indicateur)
      print(nrow(tagged_triplet_bis))
      updateSelectizeInput(session = session,inputId = "tags", choices=tags_corres$tags)
    }
  })
  
}


runApp(list(
    ui = ui_carto,
    server = servr
  ))

Ré-entraînement du modèle

Vous disposez de tout le code nécessaire, attention à ne pas relancer des étapes inutiles, il vous suffira de partir de la section Machine Learning > Préparation > Echantillonnage train-test.

Bien sûr il est préférable de mettre le code dans un script .R à part et de l’invoquer avec source.